MacHack 1996/MacHack 1996.toast/Presentations/Presentations ’91/MPW Stand-Alone Libraries/UMultiSegSA.incl.p

Text File | 1991-03-02 | 29.7 KB | 1,108 lines | [TEXT/MPS ]

{ A useful type definitions for routines that manipulate    }
{ the main jumptable and gather information about segments. }

TYPE
    IntArray = ARRAY [0..maxInt] OF Integer;
    IArrPtr = ^IntArray;
    IArrHdl = ^IArrPtr;

    SegmentInfo = RECORD
        firstProc:    Integer;    { offset of first proc in main jump table }
        numJTProcs:    Integer;    { number of procs in the main jump table }
    END;



{--------------------------------------------------------------------------------------------------}

{$S TInit}

PROCEDURE TMultiSegSA.IMultiSegSA(aFile: FileSpec;
                            mainType: ResType;
                            mainID: Integer;
                            mainName: StringHandle;
                            otherType: ResType);
    VAR
        aStrHdl:    StringHandle;

    BEGIN
        fSrcRefNum    := 0;
        fDestRefNum    := 0;
        fFileSpec    := aFile;
        fMainType    := mainType;
        fMainID        := mainID;
        fOtherType    := otherType;

        IF (mainName <> NIL) THEN
            BEGIN
            aStrHdl        := mainName;
            FailOSErr(HandToHand(Handle(aStrHdl)));
            fMainName    := aStrHdl;
            END
        ELSE
            fMainName    := NIL;

        { These must be initialzed to their "empty" table sizes or havoc will ensue }
        fJTSize        := 4;
        fCtorJTSize    := 4;
        fDtorJTSize    := 4;
        fSegTabSize    := 4;

        { Standalone code size is the above plus size of BSR, and multiseg type }
        fSACodeSize    := 8 + fJTSize + fCtorJTSize + fDtorJTSize + fSegTabSize;
    END;

{--------------------------------------------------------------------------------------------------}

{$S TRes}

{ Attempt to open the source resource fork and create the destination resource }
{ fork. Delete the destination resource fork if it exists prior to attempting }
{ to create it. }

PROCEDURE TMultiSegSA.OpenFiles;

    VAR
        tempName:    Str255;
        fi:            FailInfo;
        err:        OSErr;

    PROCEDURE HdlFailure(error: Integer; message: LongInt);
        BEGIN
            IF (fSrcRefNum <> 0) AND (fSrcRefNum <> -1) THEN CloseResFile(fSrcRefNum);
            IF (fDestRefNum <> 0) AND (fDestRefNum <> -1) THEN CloseResFile(fDestRefNum);
            tempName := concat('An error occured while opening the file ',tempName);
            gMakeSA.Stop(tempName);
        END;

    BEGIN
        CatchFailures(fi, HdlFailure);

        tempName := fFileSpec.fileName^^;
        tempName := concat(tempName, kSASuffix);

        fDestRefNum := OpenResFile(tempName);        { open destination file }
        IF (fDestRefNum = -1) OR (fDestRefNum = 0) THEN
            BEGIN
                err := ResError;
                IF (err = resFNotFound) OR (err = fnfErr) THEN
                    BEGIN
                        CreateResFile(tempName);        { create destination file }
                        FailResError;
                        fDestRefNum := OpenResFile(tempName);
                        FailResError;
                    END
                ELSE
                    FailResError;
            END;

        tempName := fFileSpec.fileName^^;
        fSrcRefNum := OpenResFile(tempName);        { open source file }
        IF (fSrcRefNum = -1) OR (fSrcRefNum = 0) THEN FailResError;

        Success(fi);
    END;

{--------------------------------------------------------------------------------------------------}

{$S TRes}

PROCEDURE TMultiSegSA.CloseSourceFile;

    BEGIN
        CloseResFile(fSrcRefNum);    { We're done with the source file }
    END;

{--------------------------------------------------------------------------------------------------}

{$S TRes}

PROCEDURE TMultiSegSA.CloseDestinationFile;

    BEGIN
        CloseResFile(fDestRefNum);    { We're done with the destination file }
    END;

{--------------------------------------------------------------------------------------------------}

{$S TRes}

PROCEDURE TMultiSegSA.ShowNumericalProgress(aStr: Str255; aLong: LongInt);

    VAR
        tempStr:    Str255;

    BEGIN
        NumToString(aLong, tempStr);
        tempStr := Concat(aStr, tempStr);
        gMakeSA.DoShowProgress(tempStr);
    END;

{--------------------------------------------------------------------------------------------------}

{$S TRes}

PROCEDURE TMultiSegSA.ShowTextProgress(aStr: Str255);

    BEGIN
        gMakeSA.DoShowProgress(aStr);
    END;

{--------------------------------------------------------------------------------------------------}

{$S TRes}

PROCEDURE TMultiSegSA.ReplaceSegment(theRsrc: Handle; theType: ResType; theID: Integer; VAR theName: Str255);

    VAR
        tempHdl:    Handle;
        tempAttrs:    Integer;

BEGIN
    SetResLoad(FALSE);                        { if the rsrc exists, dispose of it }
    tempHdl := NIL;
    tempHdl := Get1Resource(theType, theID);
    IF (tempHdl <> NIL) THEN
        BEGIN
            tempAttrs := GetResAttrs(tempHdl);
            tempAttrs := BAND(tempAttrs, $FFF7);
            SetResAttrs(tempHdl, tempAttrs);    { Turn off the protect bit }
            RmveResource(tempHdl);
            FailResError;
            DisposHandle(tempHdl);
        END;
    SetResLoad(TRUE);

    AddResource(theRsrc, theType, theID, theName);
    FailResError;
    WriteResource(theRsrc);
    FailResError;
END;


{--------------------------------------------------------------------------------------------------}

{$S TRes}

PROCEDURE TMultiSegSA.AddMainSegment(VAR saCode: Handle);

    VAR
        fi:            FailInfo;
        tempName:    Str255;

    PROCEDURE HdlAddFailure(error: Integer; message: LongInt);
        BEGIN
            SetResLoad(TRUE);
            IF (saCode <> NIL) THEN DisposHandle(saCode);
            UseResFile(fSrcRefNum);            { reset to our src rsrc file }
            CloseResFile(fDestRefNum);
        END;

    PROCEDURE HdlUpdateFailure(error: Integer; message: LongInt);
        BEGIN
            IF (saCode <> NIL) THEN ReleaseResource(saCode);
            UseResFile(fSrcRefNum);            { reset to our src rsrc file }
            CloseResFile(fDestRefNum);
        END;

    BEGIN
        CatchFailures(fi, HdlAddFailure);
        UseResFile(fDestRefNum);            { set to our dest rsrc file before adding resource }
        IF (fMainName <> NIL) THEN
            tempName := fMainName^^
        ELSE
            tempName := '';
        ReplaceSegment(saCode, fMainType, fMainID, tempName);
        Success(fi);

        CatchFailures(fi, HdlUpdateFailure);
        UpdateResFile(fDestRefNum);
        FailResError;
        ReleaseResource(saCode);
        UseResFile(fSrcRefNum);                { reset to our src rsrc file }
        Success(fi);
    END;

{--------------------------------------------------------------------------------------------------}

{$S TRes}

PROCEDURE TMultiSegSA.AddOtherCodeSegments(saCode: Handle; otherSegType: ResType);

    TYPE
        SACodeType = (sepSeg, mainSeg, jtSeg, ctordtorSeg);

        CodeDesc = RECORD
            codeID:        Integer;
            codeName:    Str255;
            codeSize:    LongInt;
            rsrcType:    ResType;
            codeType:    SACodeType;
        END;

    VAR
        theCode:    Handle;
        i, newID:    Integer;
        theCount:    Integer;
        fi:            FailInfo;
        codeArray:    TDynamicArray;
        aCodeDesc:    CodeDesc;
        segInfo:    SegmentInfo;

    FUNCTION ForThisItemDo(index: ArrayIndex): BOOLEAN;
        VAR
            aCodeDesc: CodeDesc;
        BEGIN
            codeArray.GetElementsAt(index, @aCodeDesc, 1);
            ShowNumericalProgress('CodeID ', aCodeDesc.codeID);
            ShowNumericalProgress('Index  ', index);
            ForThisItemDo := FALSE;
        END;

    PROCEDURE AddCodeInfo(VAR aCodeDesc: CodeDesc; aCodeArray: TDynamicArray);
        VAR
            lower, upper, k:    ArrayIndex;
            arraySize:    ArrayIndex;
            temp:        CodeDesc;
        BEGIN
            lower := 1;
            arraySize := aCodeArray.GetSize;
            upper := arraySize;
            REPEAT
                k := (lower + upper) DIV 2;
                aCodeArray.GetElementsAt(k, @temp, 1);
                IF (aCodeDesc.codeID < temp.codeID) THEN
                    upper := k - 1
                ELSE
                    lower := k + 1;
            UNTIL ((aCodeDesc.codeID = temp.codeID) OR (lower > upper));

            IF (aCodeDesc.codeID = temp.CodeID) THEN
                aCodeArray.InsertElementsBefore(k, @aCodeDesc, 1)
            ELSE
                aCodeArray.InsertElementsBefore(arraySize + 1, @aCodeDesc, 1);
        END;


    PROCEDURE CollateCodeInfo(count: Integer; aCodeArray: TDynamicArray);
        VAR
            aCodeDesc:    CodeDesc;
            theCode:    Handle;
            dummy:        ArrayIndex;
            theID:        Integer;
            theType:    ResType;
            theName:    Str255;
            i:            Integer;
        BEGIN
            SetResLoad(FALSE);
            { Collect code resources info, and sort by ID }
            FOR i := 1 TO count DO
                BEGIN
                    theCode := NIL;
                    theCode := Get1IndResource('CODE', i);
                    FailNilResource(theCode);
                    GetResInfo(theCode, theID, theType, theName);
                    FailResError;

                    WITH aCodeDesc DO
                        BEGIN
                            codeID := theID;
                            codeName := theName;
                            codeSize := SizeResource(theCode);
                            rsrcType := theType;

                            IF (theID = 0) THEN
                                codeType := jtSeg
                            ELSE IF (theName = kCtorDtorSeg) THEN
                                codeType := ctordtorSeg
                            ELSE IF (WillBeMerged(theID, theName)) THEN
                                codeType := mainSeg
                            ELSE
                                codeType := sepSeg;
                        END;
                    ReleaseResource(theCode);
                    AddCodeInfo(aCodeDesc, aCodeArray);
                END;
{•}            dummy := aCodeArray.EachElementDoTil(ForThisItemDo, kIterateForward);
            SetResLoad(TRUE);
        END;

    PROCEDURE HdlAddFailure(error: Integer; message: LongInt);
        BEGIN
            { Free the code segment }
            IF (theCode <> NIL) THEN DisposHandle(theCode);

            SetResLoad(TRUE);                { CollateCodeInfo turns it off }
            UpdateResFile(fDestRefNum);        { force the rsrc map to be updated }
            UseResFile(fSrcRefNum);            { reset to our src rsrc file }
            codeArray.Free;                    { free the code elements }
        END;


    BEGIN
        theCount := Count1Resources('CODE');
        IF (theCount <= 0) THEN Failure(resNotFound, 0);

        New(codeArray);
        FailNil(codeArray);
        codeArray.IDynamicArray(theCount, SizeOf(CodeDesc));

        CatchFailures(fi, HdlAddFailure);

        CollateCodeInfo(theCount, codeArray);

        { Move the non-main code resources into the new file }
        { Make sure we start at ID = 1. The main entry point }
        { must be in ID = 0.                                 }
        newID := 1;
        FOR i := 1 TO theCount DO
            BEGIN
                codeArray.GetElementsAt(i, @aCodeDesc, 1);
                theCode := NIL;
                theCode := Get1Resource('CODE', aCodeDesc.codeID);
                FailNilResource(theCode);
                { Have we found a code segment to be added as a seperate segment, maybe }
                IF (aCodeDesc.codeType = sepSeg) THEN
                    BEGIN
                        ShowNumericalProgress('Adding segment ', aCodeDesc.codeID);
                        { rsrc mgr will think it belongs elsewhere if not detached }
                        DetachResource(theCode);
                        UseResFile(fDestRefNum);
                        ReplaceSegment(theCode, otherSegType, newID, aCodeDesc.codeName);
                        UseResFile(fSrcRefNum);
                        { Get segment info and then modify it's SA jumptable entry }
                        BlockMove(theCode^, @segInfo, SizeOf(SegmentInfo));
                        AdjustMainJTable(saCode, 0, aCodeDesc.codeID, newID, segInfo.firstProc, segInfo.numJTProcs);
                        ShowNumericalProgress('Added segment as ', newID);
                        newID := newID + 1;
                    END;
                ReleaseResource(theCode);
            END;
        UpdateResFile(fDestRefNum);        { force the rsrc map to be updated }
        codeArray.Free;                    { Release the storage for the array }
        Success(fi);
    END;

{--------------------------------------------------------------------------------------------------}

{$S TRes}


PROCEDURE TMultiSegSA.CalcJTSize(rawJTSize: LongInt);

    VAR
        tempLong:    LongInt;

    BEGIN
        IF (rawJTSize = 0) THEN
            tempLong := 4
        ELSE
            tempLong := 4 + ((rawJTSize - kCode0Hdr) DIV kJTDivisor);
        ShowNumericalProgress('Main jumptable size = ', tempLong);
        fJTSize := tempLong;
    END;

{--------------------------------------------------------------------------------------------------}

{$S TRes}

PROCEDURE TMultiSegSA.CalcCtorJTSize(theSize: LongInt);

    VAR
        tempLong:    LongInt;

    BEGIN
        IF (theSize = 0) THEN
            tempLong := 4
        ELSE
            tempLong := 4 + ((theSize - kCodeHdr) DIV 2);
        ShowNumericalProgress('Ctor jumptable size = ', tempLong);
        fCtorJTSize := tempLong;
    END;

{--------------------------------------------------------------------------------------------------}

{$S TRes}

PROCEDURE TMultiSegSA.CalcDtorJTSize(theSize: LongInt);

    VAR
        tempLong:    LongInt;

    BEGIN
        IF (theSize = 0) THEN
            tempLong := 4
        ELSE
            tempLong := 4 + ((theSize - kCodeHdr) DIV 2);
        ShowNumericalProgress('Dtor jumptable size = ', tempLong);
        fDtorJTSize := tempLong;
    END;

{--------------------------------------------------------------------------------------------------}

{$S TRes}

PROCEDURE TMultiSegSA.CalcSegTableSize(theCount: Integer; hasCtorDtorJT: Boolean);

    VAR
        tempSize:    LongInt;

    BEGIN
        IF hasCtorDtorJT THEN            { if there is a static ctor/dtor jtable then }
            tempSize := theCount - 2    { don't include it & code 0 it in our SegTable }
        ELSE
            tempSize := theCount - 1;    { otherwise leave out only code 0 }

        IF (theCount <= 0) THEN
            tempSize := 4
        ELSE
            tempSize := 4 + (tempSize * 4);
        ShowNumericalProgress('Segment table size = ', tempSize);
        fSegTabSize := tempSize;
    END;

{--------------------------------------------------------------------------------------------------}

{$S TRes}

FUNCTION TMultiSegSA.GetNumJTEntries: LongInt;

    VAR
        tempLong:    LongInt;

    BEGIN
        tempLong := (GetJTSize - 4) DIV 4;
        ShowNumericalProgress('Number of main jumptable entries = ', tempLong);
        GetNumJTEntries := tempLong;
    END;

{--------------------------------------------------------------------------------------------------}

{$S TRes}

FUNCTION TMultiSegSA.GetNumCtorJTEntries: LongInt;

    VAR
        tempLong:    LongInt;

    BEGIN
        tempLong := (GetCtorJTSize - 4) DIV 2;
        ShowNumericalProgress('Number of static ctor jumptable entries = ', tempLong);
        GetNumCtorJTEntries := tempLong;
    END;

{--------------------------------------------------------------------------------------------------}

{$S TRes}

FUNCTION TMultiSegSA.GetNumDtorJTEntries: LongInt;

    VAR
        tempLong:    LongInt;

    BEGIN
        tempLong := (GetDtorJTSize - 4) DIV 2;
        ShowNumericalProgress('Number of static dtor jumptable entries = ', tempLong);
        GetNumDtorJTEntries := tempLong;
    END;

{--------------------------------------------------------------------------------------------------}

{$S TRes}

FUNCTION TMultiSegSA.GetNumSegTableEntries: LongInt;

    VAR
        tempLong:    LongInt;

    BEGIN
        tempLong := (GetSegTableSize - 4) DIV 4;
        ShowNumericalProgress('Number of segment table entries = ', tempLong);
        GetNumSegTableEntries := tempLong;
    END;

{--------------------------------------------------------------------------------------------------}

{$S TRes}

FUNCTION TMultiSegSA.GetJTSize: LongInt;

    BEGIN
        GetJTSize := fJTSize;
    END;

{--------------------------------------------------------------------------------------------------}

{$S TRes}

FUNCTION TMultiSegSA.GetCtorJTSize: LongInt;

    BEGIN
        GetCtorJTSize := fCtorJTSize;
    END;

{--------------------------------------------------------------------------------------------------}

{$S TRes}

FUNCTION TMultiSegSA.GetDtorJTSize: LongInt;

    BEGIN
        GetDtorJTSize := fDtorJTSize;
    END;

{--------------------------------------------------------------------------------------------------}

{$S TRes}

FUNCTION TMultiSegSA.GetSegTableSize: LongInt;

    BEGIN
        GetSegTableSize := fSegTabSize;
    END;

{--------------------------------------------------------------------------------------------------}

{$S TRes}

FUNCTION TMultiSegSA.GetSACodeSize: LongInt;

    BEGIN
        GetSACodeSize := fSACodeSize;
    END;

{--------------------------------------------------------------------------------------------------}

{$S TRes}
{ We're only concerned with CODE 1 here. All other normal code segments }
{ will not be merged into the standalone code resources. Thus they are "filtered out" }
{ by this method. This method must be overridden if you need to change which }
{ code segments are merged into the final standalone CODE segment. }

FUNCTION TMultiSegSA.WillBeMerged(theID: Integer; theName: Str255): BOOLEAN;

    BEGIN
        IF (theID = 1) THEN { We are only concerned with CODE 1 }
            WillBeMerged := TRUE
        ELSE
            WillBeMerged := FALSE;
    END;

{--------------------------------------------------------------------------------------------------}

{$S TRes}

PROCEDURE TMultiSegSA.CalcSACodeSize;

    VAR
        theCode:        Handle;
        i:                Integer;
        theCount:        Integer;
        theID:            Integer;
        theType:        ResType;
        theName:        Str255;
        theSize:        LongInt;
        fi:                FailInfo;
        hasCtorDtorJT:    Boolean;

    PROCEDURE HdlFailure(error: Integer; message: LongInt);

        VAR
            tempName:    Str255;
            tempLong:    LongInt;

        BEGIN
            tempName := fFileSpec.fileName^^;
            CASE error OF
                resNotFound:
                    WriteLn(kErrorMarker, tempName, ' does not contain CODE resources.');
                OTHERWISE
                    WriteLn(kErrorMarker, tempName, ' error occured while scanning CODE resources.');
            END;
        END;

    BEGIN
        CatchFailures(fi, HdlFailure);
        SetResLoad(FALSE);    { We only want info on the rsrc's. DONT LOAD THEM! }

        { The first thing in the SACode is the BSR instruction. }
        fSACodeSize := kBSRSize;

        { Now add in the size of the segment's resource type }
        fSACodeSize := fSACodeSize + kSegTypeSize;

        theCount := Count1Resources('CODE');
        IF (theCount <= 0) THEN Failure(resNotFound, 0);

        hasCtorDtorJT := FALSE;        { assume there are no static ctor and dtors }

        { Sum the CODE segment sizes. However, watch out for special segments, and }
        { don't add the sizes of anything other than code 0 and code 1 }
        FOR i := 1 TO theCount DO
            BEGIN
                theCode := NIL;
                theCode := Get1IndResource('CODE', i);
                FailNilResource(theCode);
                theSize := SizeResource(theCode);
                GetResInfo(theCode, theID, theType, theName);
                ReleaseResource(theCode);

                IF (theID = 0) THEN                        { Found jump table }
                    BEGIN
                        CalcJTSize(theSize);
                    END
                ELSE IF (theName = kCtorDtorSeg) THEN    { Found CtorDtor jump table }
                    BEGIN
                        CalcCtorJTSize(theSize);
                        CalcDtorJTSize(theSize);
                        hasCtorDtorJT := TRUE;
                    END
                ELSE IF WillBeMerged(theID, theName) THEN    { Found a code segment we'll merge }
                    fSACodeSize := fSACodeSize + theSize - kCodeHdr;
            END;

        CalcSegTableSize(theCount, hasCtorDtorJT);

        theSize := fSACodeSize + GetJTSize + GetCtorJTSize + GetDtorJTSize + GetSegTableSize;
        ShowNumericalProgress('Estimated standalone size = ', theSize);
        IF (theSize > maxInt) THEN
            gMakeSA.Stop('Main code segement exceeds 32K');
        fSACodeSize := theSize;

        SetResLoad(TRUE);
        Success(fi);
    END;

{--------------------------------------------------------------------------------------------------}

{$S TRes}

FUNCTION TMultiSegSA.AllocateSACode(theSize: LongInt): Handle;

    VAR
        aHandle:    Handle;

    BEGIN
        aHandle := NIL;
        aHandle := NewHandle(theSize);
        FailNIL(aHandle);
        AllocateSACode := aHandle;
    END;

{--------------------------------------------------------------------------------------------------}

{$S TRes}

FUNCTION TMultiSegSA.GetCode0: Handle;

    VAR
        aHandle:    Handle;

    BEGIN
        aHandle := NIL;
        aHandle := Get1Resource('CODE', 0);
        FailNilResource(aHandle);
        GetCode0 := aHandle;
    END;

{--------------------------------------------------------------------------------------------------}

{$S TRes}

FUNCTION TMultiSegSA.GetCtorDtorJT: Handle;

    VAR
        aHandle:    Handle;

    BEGIN
        aHandle := NIL;
        aHandle := Get1NamedResource('CODE', kCtorDtorSeg);
        { *** This can fail because not every piece of code has *** }
        { *** a CtorDtor jumptable. Thus we can't call FailNil! *** }
        IF (ResError <> noErr) THEN
            aHandle := NIL;
        GetCtorDtorJT := aHandle;
    END;

{--------------------------------------------------------------------------------------------------}

{$S TRes}

PROCEDURE TMultiSegSA.BuildBSR(code0, saCode: Handle; VAR saPos: LongInt);

    VAR
        theBSRinst:        LongInt;    { The full BSR $XXXX instruction goes here }
        theEntryPt:        Integer;    { 1st entry in original main jumptable has offset to MAIN }
        theOffset:        Integer;    { Our calculated offset to main entry point }

    BEGIN
        { offset to main entry point of SARuntime is 1st entry in main jumptable }
        BlockMove(Ptr(ORD(code0^)+kCode0Hdr), @theEntryPt, 2);

        { move the BSR instruction into the standalone and set it to BSR to MAIN }
        theBSRinst := BSL(kBSRCode, 16);
        theOffset := kSegTypeSize + GetJTSize + GetCtorJTSize + GetDtorJTSize + GetSegTableSize;
        theOffset := theOffset + theEntryPt + 2;
        theBSRinst := theBSRinst + theOffset;
        BlockMove(@theBSRinst, Ptr(ORD(saCode^)+saPos), kBSRSize);
        saPos := saPos + kBSRSize;
        ShowNumericalProgress('BSR offset to main proc is: ', theOffset);
        ShowNumericalProgress('BSR to main proc ends at: ', saPos);
    END;

{--------------------------------------------------------------------------------------------------}

{$S TRes}

PROCEDURE TMultiSegSA.BuildSegType(segType: ResType; saCode: Handle; VAR saPos: LongInt);

    BEGIN
        { move the BSR instruction into the standalone and set it to BSR to MAIN }
        BlockMove(@segType, Ptr(ORD(saCode^)+saPos), kSegTypeSize);
        ShowNumericalProgress('Offset to segment restype is: ', saPos);
        saPos := saPos + kSegTypeSize;
    END;

{--------------------------------------------------------------------------------------------------}

{$S TRes}

PROCEDURE TMultiSegSA.BuildJumpTable(code0, saCode: Handle; VAR saPos: LongInt);

    TYPE
        JTEntry = RECORD
            offset:        Integer;
            move:        Integer;
            segNum:        Integer;
            loadSeg:    Integer;
        END;

    VAR
        numJTEntries:    LongInt;
        code0Pos:        LongInt;
        theEntry:        JTEntry;
        i:                Integer;

    BEGIN
        { move the numJTEntries into the standalone }
        numJTEntries := GetNumJTEntries;
        BlockMove(@numJTEntries, Ptr(ORD(saCode^)+saPos), kNumJTSize);
        saPos := saPos + kNumJTSize;

        code0Pos := kCode0Hdr;
        FOR i := 0 TO numJTEntries-1 DO
            BEGIN
                BlockMove(Ptr(ORD(code0^)+code0Pos), @theEntry, SizeOf(JTEntry));
                BlockMove(@theEntry.offset, Ptr(ORD(saCode^)+saPos), 2);
                BlockMove(@theEntry.segNum, Ptr(ORD(saCode^)+saPos+2), 2);
                code0Pos := code0Pos + SizeOf(JTEntry);
                saPos := saPos + 4;
            END;
        ShowNumericalProgress('Main jump table ends at: ', saPos);
    END;

{--------------------------------------------------------------------------------------------------}

{$S TRes}

PROCEDURE TMultiSegSA.BuildCtorJTable(theJT, saCode: Handle; VAR saPos: LongInt);

    VAR
        saveSAPos:    LongInt;
        theJTPos:    LongInt;
        numEntries:    LongInt;    { number of Ctor JT entries we actually find }
        count:        Integer;    { number of Ctor JT entries we think there are }
        theEntry:    Integer;
        i:            Integer;

    BEGIN
        saveSAPos := saPos;                { remember this for when we stuff # JT entries }
        count := GetNumCtorJTEntries;    { This was determined earlier }
        numEntries := 0;                { we'll assume that there are null entries }
        theJTPos := kCodeHdr;            { skip over code header }
        saPos := saPos + kNumJTSize;    { leave room at top for num of JT entries }

        IF (theJT = NIL) THEN            { Whoops! Handle this as best we can... }
            count := 0;

        { Remember that ctor entries are every other _even_ word offset after code header }
        FOR i := 0 TO count-1 DO
            BEGIN
                BlockMove(Ptr(ORD(theJT^)+theJTPos), @theEntry, 2);
                IF (theEntry <> 0) THEN                    { skip over null entry }
                    BEGIN
                        BlockMove(@theEntry, Ptr(ORD(saCode^)+saPos), 2);
                        saPos := saPos + ((i + 1) * 2);    { bump offset up one word }
                        numEntries := numEntries + 1;
                    END;
                theJTPos := theJTPos + ((i + 1) * 2);    { bump offset up one word }
            END;

        { Now move in the number of JT entries at top of table }
        BlockMove(@numEntries, Ptr(ORD(saCode^)+saveSAPos), kNumJTSize);
        ShowNumericalProgress('Ctor table ends at: ', saPos);
    END;

{--------------------------------------------------------------------------------------------------}

{$S TRes}

PROCEDURE TMultiSegSA.BuildDtorJTable(theJT, saCode: Handle; VAR saPos: LongInt);

    VAR
        saveSAPos:    LongInt;
        theJTPos:    LongInt;
        numEntries:    LongInt;    { number of Dtor JT entries we actually find }
        count:        Integer;    { number of Dtor JT entries we think there are }
        theEntry:    Integer;
        i:            Integer;

    BEGIN
        saveSAPos := saPos;                { remember this for when we stuff # JT entries }
        count := GetNumDtorJTEntries;    { This was determined earlier }

        { skip all the way to last Dtor entry. }
        { Remember that dtor entries are every other _odd_ word offset after code header }
        theJTPos := kCodeHdr + ((count-1) * 2) + 2;

        numEntries := 0;                { we'll assume that there are null entries }
        saPos := saPos + kNumJTSize;    { leave room at top for num of JT entries }

        IF (theJT = NIL) THEN            { Whoops! Handle this as best we can... }
            count := 0;

        FOR i := count-1 DOWNTO 0 DO
            BEGIN
                BlockMove(Ptr(ORD(theJT^)+theJTPos), @theEntry, 2);
                IF (theEntry <> 0) THEN                { skip over null entry }
                    BEGIN
                        BlockMove(@theEntry, Ptr(ORD(saCode^)+saPos), 2);
                        saPos := saPos + ((i + 1) * 2);    { bump offset down one word }
                        numEntries := numEntries + 1;
                    END;
                theJTPos := theJTPos - ((i + 1) * 2);    { bump offset down one word }
            END;

        { Now move in the number of JT entries at top of table }
        BlockMove(@numEntries, Ptr(ORD(saCode^)+saveSAPos), kNumJTSize);
        ShowNumericalProgress('Dtor table ends at: ', saPos);
    END;

{--------------------------------------------------------------------------------------------------}

{$S TRes}

PROCEDURE TMultiSegSA.BuildSegTable(saCode: Handle; VAR saPos: LongInt);

    TYPE
        LongArray = ARRAY [0..maxInt] OF LongInt;
        LArrPtr = ^LongArray;
        LArrHdl = ^LArrPtr;

    VAR
        i:            Integer;
        count:        Integer;
        laPtr:        LArrPtr;
        numEntries:    LongInt;
        laOffset:    LongInt;

    BEGIN
        count := GetNumSegTableEntries;
        numEntries := count;
        laOffset := saPos;
        BlockMove(@numEntries, Ptr(ORD(saCode^)+laOffset), kNumJTSize);
        laOffset := laOffset + kNumJTSize;

        HLock(saCode);
        laPtr := LArrHdl(saCode)^;
        laPtr := LArrPtr(ORD(laPtr) + laOffset);
        FOR i := 0 TO count-1 DO
            laPtr^[i] := 0;
        saPos := saPos + GetSegTableSize;
        HUnlock(saCode);
        ShowNumericalProgress('Segment table ends at: ', saPos);
    END;

{--------------------------------------------------------------------------------------------------}

{$S TRes}

PROCEDURE TMultiSegSA.AdjustMainJTable(saCode: Handle;
                                    segOffset:    LongInt;
                                    oldSegNum, newSegNum, jtOffset, numEntries: Integer);
    VAR
        i:                Integer;
        iaPtr:            IArrPtr;
        jtEntry:        Integer;
        segEntry:        Integer;
        nextOffset:        Integer;
        myJTOffset:        Integer;
        fi:                FailInfo;

    PROCEDURE HdlFailure(error: Integer; message: LongInt);

        VAR
            shortStr:    Str15;
            tempStr:    Str255;

        BEGIN
            IF (saCode <> NIL) THEN HUnlock(saCode);
            NumToString(error, tempStr);
            shortStr := tempStr;
            NumToString(message, tempStr);
            tempStr := concat('Original segment was ', shortStr, ' whereas segment being merged is ', tempStr);
            WriteLn(Diagnostic,
                'Segment number mismatch occured while adjusting main jump table.');
            WriteLn(Diagnostic, tempStr);
        END;

    BEGIN
        CatchFailures(fi, HdlFailure);
        HLock(saCode);
        myJTOffset := jtOffset DIV 4;    { original jumptable entry is 8 bytes, divide by 4 }
        iaPtr := IArrHdl(saCode)^;
        iaPtr := IArrPtr(ORD(iaPtr) + kJTStart);    { point to beginning of SA jumptable }
        FOR i := 0 TO numEntries-1 DO
            BEGIN
                nextOffset := myJTOffset + (i * 2);
                jtEntry := iaPtr^[nextOffset];
                segEntry := iaPtr^[nextOffset+1];
                IF (segEntry <> oldSegNum) THEN
                    Failure(segEntry, oldSegNum);
                iaPtr^[nextOffset] := jtEntry + segOffset;
                iaPtr^[nextOffset+1] := newSegNum;    { Set the segment number to the new value }
            END;
        HUnlock(saCode);
        Success(fi);
    END;

{--------------------------------------------------------------------------------------------------}

{$S TRes}

PROCEDURE TMultiSegSA.Merge1Segment(segNum: Integer; theCode: Handle; codeSize: LongInt;
                                saCode: Handle; VAR saPos: LongInt);

    VAR
        segInfo:    SegmentInfo;
        mySize:        LongInt;

    BEGIN
        mySize := codeSize - kCodeHdr;    { strip off the header }

        { Get the segment info }
        BlockMove(theCode^, @segInfo, SizeOf(SegmentInfo));

        { Move the segment into standalone code, but not code header }
        BlockMove(Ptr(ORD(theCode^)+kCodeHdr),
                    Ptr(ORD(saCode^)+saPos), mySize);

        { We are only going to adjust the segment that the main entry }
        { point is in. That is _always_ segment zero!                 }
        AdjustMainJTable(saCode, saPos, segNum, 0, segInfo.firstProc, segInfo.numJTProcs);
        saPos := saPos + mySize;
    END;

{--------------------------------------------------------------------------------------------------}

{$S TRes}

PROCEDURE TMultiSegSA.MergeCodeSegments(saCode: Handle; VAR saPos: LongInt);

    VAR
        theCode:    Handle;
        theSize:    LongInt;

    BEGIN
        { merge in CODE 1 first! }
        theCode := NIL;
        theCode := Get1Resource('CODE', 1);
        FailNilResource(theCode);
        theSize := SizeResource(theCode);
        Merge1Segment(1, theCode, theSize, saCode, saPos);
        ReleaseResource(theCode);
        ShowNumericalProgress('Code 1 ends at: ', saPos);

        { We only merge CODE 1 for multi-segment stand alone code.             }
        { The remaining CODE segments are left as code segments, though        }
        { we should consider renaming them.(?)  Also, because we leave         }
        { them alone, we don't have to adjust the jump table entries for these }
        { segments! (not often that the work is already done for you...)       }
    END;

{--------------------------------------------------------------------------------------------------}

{$S TRes}

PROCEDURE TMultiSegSA.BuildStandAlone;

    VAR
        code0:        Handle;
        ctordtorJT:    Handle;
        saCode:        Handle;
        pos:        LongInt;
        fi:            FailInfo;

    PROCEDURE HdlFailure(error: Integer; message: LongInt);
        BEGIN
            IF (saCode <> NIL) THEN DisposHandle(saCode);
            IF (code0 <> NIL) THEN ReleaseResource(code0);
            IF (ctordtorJT <> NIL) THEN ReleaseResource(ctordtorJT);
        END;

    BEGIN
        code0 := NIL;
        saCode := NIL;
        pos := 0;

        CatchFailures(fi, HdlFailure);

        saCode := AllocateSACode(GetSACodeSize);

        code0 := GetCode0;
        BuildBSR(code0, saCode, pos);
        BuildSegType(fOtherType, saCode, pos);
        BuildJumpTable(code0, saCode, pos);
        ReleaseResource(code0);
        code0 := NIL;

        ctordtorJT := NIL;
        ctordtorJT := GetCtorDtorJT;
        BuildCtorJTable(ctordtorJT, saCode, pos);
        BuildDtorJTable(ctordtorJT, saCode, pos);
        IF (ctordtorJT <> NIL) THEN        { If we found the CtorDtor jumptable }
            ReleaseResource(ctordtorJT);

        BuildSegTable(saCode, pos);

        MergeCodeSegments(saCode, pos);
        ShowNumericalProgress('Final size of standalone is: ', pos);

        AddOtherCodeSegments(saCode, fOtherType);

        SetHandleSize(saCode, pos);        { Shorten handle size to actual length used }
        AddMainSegment(saCode);
        CloseSourceFile;
        CloseDestinationFile;
        Success(fi);
        ShowTextProgress('Done.');
    END;

{--------------------------------------------------------------------------------------------------}

{$S TRes}
{ Take a file, extract the various needed CODE resources and massage }
{ them into the single standalone code resource. }

PROCEDURE TMultiSegSA.DoIt;

    BEGIN
        OpenFiles;

        CalcSACodeSize;

        BuildStandAlone;
    END;

{--------------------------------------------------------------------------------------------------}